home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Dr. Windows 3
/
dr win3.zip
/
dr win3
/
PROGRAMR
/
WPJV1N7.ZIP
/
RTFGEN.ZIP
/
RTFGEN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-02-23
|
18KB
|
803 lines
{ RTFGEN }
(********* Source code (C) Copyright 1992, by L. David Baldwin *********)
(********* All Rights Reserved *********)
{$A+,B-,E-,F-,G-,I+,N-,O-,R-,S-,V-,X-}
{$M 16384,0,0}
PROGRAM RTFGEN;
Uses Crt{, MySubs};
Const
TwipsPerSpace = 120;
DefaultFont : String[6] = '2';
DefaultFontSize : String[10] = '20';
ParaChar : Char = '`';
Tokenleng = 28; {Max symbol length}
Tab = #9;
MaxRes = 13;
Type
Symb = (
OtherChar, Comma, Colon, SemiColon, Lbrack, Rbrack, Dot, Slash,
LLbrack, RRbrack, OtherPunct, Ident, EolSy, Space, ParaSy, TabSy,
BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy,
TopicStart, TopicEnd, DocStartSy, DocEndSy, CommandSy, BMCSy, BMLSy,
BMRSy, FontCommand, Number, BlockStartSy, BlockEndSy);
SymString = string[14];
Var
Sy, SaveSy : Symb;
Const
ResWord : array[1..MaxRes] of SymString = (
'\buildtag', '\topic', '\title', '\keyword', '\browse', '\bmc', '\bml',
'\bmr', '\docstart', '\docend', '\tab', '\blockstart', '\blockend');
ResSy : array[1..MaxRes] of Symb = (
BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy, BMCSy, BMLSy,
BMRSy, DocStartSy, DocEndSy, TabSy, BlockStartSy, BlockEndSy);
Type
TokenString = string[Tokenleng];
String127 = string[127];
Filestring = string[64];
PairType = array[0..1] of Char;
Var
BrackCount, LineNo, Chi, ErrCount : Integer;
Pair : Word;
Spair : PairType absolute Pair;
LCh : Char absolute Pair;
UCh : Char;
St : String127;
ErrFlag, EofInf, InInclude, InTopic : Boolean;
SourceName : Filestring;
Inf, Outf : Text;
InBuff, OutBuff : array[1..1000] of Char;
Value : LongInt;
LCToken : TokenString;
OutString, GlobalHeader, TopicHeader : String;
BlockHeader : array[1..4] of String;
BIndex : Integer;
{-------------Error}
PROCEDURE Error(II :Integer; S :String127);
Var X,Y : Integer;
NewS : String127;
begin
GotoXY(1,WhereY);
WriteLn(St);
Y:=WhereY;
X:=II-3; if X<1 then X:=1;
GotoXY(X, Y);
Write('^');
Str(LineNo, NewS);
NewS := NewS + ' Error';
if S[0]>#0 then NewS:=NewS + ', '+S;
if X+Ord(NewS[0])>80 then X:=X-Ord(NewS[0]) else X:=X+1;
GotoXY(X,Y); WriteLn(NewS);
ErrCount:=Succ(ErrCount);
if ErrCount>6 then
begin
WriteLn('Excessive Number of Errors');
Halt(1);
end;
ErrFlag := True;
end;
{-------------Positn}
function Positn(Pat, Src : String; I : Integer) : Integer;
{find the position of a substring in a string starting at the Ith char}
var
N : Integer;
begin
if I < 1 then I := 1;
Delete(Src, 1, I-1);
N := Pos(Pat, Src);
if N = 0 then Positn := 0
else Positn := N+I-1;
end;
{-------------OutFile}
PROCEDURE OutFile(S : String);
var
WriteIt : boolean;
Leng, I : Integer;
begin
{a hard to find bug is mismatched braces. Keep count of these so
can keep track of matching.}
I := 0;
repeat
I := Positn('{', S, I+1);
if (I > 0) then
if not ((I > 1) and (S[I-1] = '\')) then Inc(BrackCount);
until I = 0;
repeat
I := Positn('}', S, I+1);
if (I > 0) then
if not ((I > 1) and (S[I-1] = '\')) then Dec(BrackCount);
until I = 0;
{try to avoid hanging spaces on end of lines as editors delete them}
Leng := Length(OutString)+Length(S);
WriteIt := (Leng >= 75) and (OutString[Length(OutString)] <> ' ')
or (Leng >= 200);
if WriteIt then
begin
WriteLn(Outf, OutString);
OutString := S;
end
else OutString := OutString+S;
end;
{-------------Flush}
PROCEDURE Flush;
begin
if Length(OutString) > 0 then
begin WriteLn(OutF, OutString); OutString := ''; end;
end;
{-------------GetCh}
PROCEDURE GetCh;
{Return next char in Uch and Lch with Uch in upper case. Ignore comments}
Var Comment : Boolean;
PROCEDURE GetchBasic; {read a character and a character pair}
begin
if Chi<=Ord(St[0]) then
begin {NOTE: pair has the same address as lch}
Pair := MemW[DSeg : Ofs(St[Chi])];
if (LCh=Tab) and not InTopic then LCh:=' ';
UCh := UpCase(LCh);
Chi := Chi+1;
end
else
if not EOF(Inf) then
begin
ReadLn(Inf,St);
Inc(LineNo);
St:=St+^M; {Add EOL}
Chi:=1;
GetCh;
end
else
begin
EofInf:=True;
if Comment then
begin
WriteLn('Open Comment at End of Input File');
Halt(1);
end;
end;
end;
begin {Getch}
repeat
if EofInf then
begin WriteLn('Unexpected End of Input File'); Halt(1) end;
Comment:=False;
GetchBasic;
if (SPair='(*') then
begin
Comment:=True;
repeat GetchBasic; until SPair='*)';
GetchBasic; {pass by the '*'}
end;
until not Comment;
end;
{-----------IsPair}
FUNCTION IsPair : Boolean;
Const
Limit = 8;
PA : array[1..Limit] of PairType = (
'[[', ']]', '\[', '\]', '\\', '\`',
'\{', '\}'); {!! <- if '`' made optional, change!!}
Var
I : Integer;
Was : Pairtype;
begin
IsPair := False;
for I := 1 to Limit do
if PA[I] = Spair then
begin
Was := SPair;
Sy := OtherPunct;
IsPair := True;
GetCh;
case I of
5,7,8 : LCToken := Was;
1 : Sy := LLbrack;
2 : Sy := RRbrack;
else LCToken := LCh;
end;
GetCh;
Exit;
end;
end;
{-------------GetNumber}
FUNCTION GetNumber : Boolean; {Pick up a Number}
Var
Done : Boolean;
Code : Integer;
begin
case UCh of
'0'..'9' : LCToken := '';
else
begin
GetNumber := False;
Exit;
end;
end;
GetNumber := True;
Sy := Number;
Done := False;
if not EofInf then
while not Done do
case UCh of
'0'..'9' :
begin
LCToken := LCToken+UCh;
GetCh;
end;
else Done := True;
end;
Val(LCToken, Value, Code);
end;
{-------------GetCommand}
FUNCTION GetCommand : Boolean; {Pick up a Command}
Label 2;
const
MaxFC = 10;
FontCommands : array[1..MaxFC] of string[6] =
('f', 'fs', 'b', 'i', 'strike', 'ul', 'ulw', 'uld', 'uldb',
'plain');
Var
Done : Boolean;
I : Integer;
AlphaOnly : TokenString;
begin
GetCommand := False;
if UCh <> '\' then Exit;
GetCommand := True;
Sy := CommandSy;
LCToken := LCh;
AlphaOnly := '';
GetCh;
Done := False;
if not EofInf then
begin
while not Done do
case LCh of
'a'..'z' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
Inc(AlphaOnly[0]);
AlphaOnly[Length(AlphaOnly)] := LCh;
end;
GetCh;
end;
else Done := True;
end;
if LCh = '-' then
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
GetCh;
end;
Done := False;
while not Done do
case LCh of
'0'..'9' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
GetCh;
end;
else Done := True;
end;
end;
for I := 1 to MaxRes do
if LCToken = ResWord[I] then
begin
Sy := ResSy[I];
GOTO 2;
end;
if not InTopic then
for I := 1 to MaxFC do
if AlphaOnly = FontCommands[I] then
begin
Sy := FontCommand;
GoTo 2;
end;
2 : {account for possible space after command}
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := ' ';
end;
if UCh = ' ' then GetCh; {use up a space}
end;
{-------------GetIdent}
FUNCTION GetIdent : Boolean; {Pick up a Symbol}
Var
Done : Boolean;
I : Integer;
begin
GetIdent := False;
case UCh of
'A'..'Z', '_' : ;
else
Exit;
end;
GetIdent := True;
Sy := Ident;
LCToken := LCh;
GetCh;
Done := False;
if not EofInf then
while not Done do
case UCh of
'A'..'Z', '0'..'9', '_' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
Ge